home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / AlphaBits.tcl next >
Encoding:
Text File  |  1999-02-08  |  9.1 KB  |  327 lines  |  [TEXT/ALFA]
  1. # First basic initialisation: (works with Alpha 7.1 or 8.0 development)
  2. if {[catch {
  3.     if {[info tclversion] < 8.0} {
  4.     ;proc namespace {cmd ns script} {if {$script != ""} {uplevel $script}}
  5.     ;proc variable {n} { global mode ; uplevel 1 [list upvar \#0 $mode::$n $n] }
  6.     ;proc renameMenuItem {args} {}
  7.     } else {
  8.     namespace eval alpha {
  9.         namespace eval index {}
  10.         namespace eval cache {}
  11.     }
  12.     namespace eval win {}
  13.     if {[info commands scancontext] == ""} {
  14.     proc scancontext {cmd args} {
  15.         switch $cmd {
  16.         "create" {
  17.             uplevel 1 {
  18.             set __scan 0
  19.             while {[array exists scancontext$__scan]} {
  20.                 incr __scan
  21.             }
  22.             set scancontext[set __scan]() 1
  23.             return scancontext$__scan
  24.             }
  25.         }
  26.         "delete" {
  27.             upvar [lindex $args 0] scan
  28.             unset scan
  29.         }
  30.         }
  31.     }
  32.     
  33.     proc scanmatch {scanid regexp script args} {
  34.         if {[string match "-*" $scanid]} {
  35.         set flags $scanid
  36.         set scanid $regexp
  37.         set regexp [list $flags $script]
  38.         set script [lindex $args 0]
  39.         } else {
  40.         set regexp [list -- $regexp]
  41.         }
  42.         upvar $scanid scan
  43.         set scan($regexp) $script
  44.         return $scanid
  45.     }
  46.     
  47.     proc scanfile {scanid fid} {
  48.         upvar $scanid scan
  49.         upvar matchInfo m
  50.         set m(linenum) 0
  51.         set m(offset) 0
  52.         set names [array names scan]
  53.         while {[set count [gets $fid m(line)]] >= 0} {
  54.         incr m(linenum)
  55.         incr m(offset) [expr {$count +1}]
  56.         foreach reg $names {
  57.             if {$reg == ""} {continue}
  58.             if {[regexp [lindex $reg 0] [lindex $reg 1] $m(line) \
  59.               "" m(submatch0) m(submatch1) m(submatch2)]} {
  60.             incr m(offset) [expr {-[string length $m(submatch0)]}]
  61.             uplevel 1 $scan($reg)
  62.             incr m(offset) [string length $m(submatch0)]
  63.             }
  64.         }
  65.         }
  66.     }
  67.         }
  68.     if {[info commands objDialog] != ""} {
  69.         rename dialog ""
  70.         rename objDialog dialog
  71.     }
  72.     rename lsort __lsort
  73.     proc lsort {args} {
  74.         if {[lindex $args 0] == "-ignore"} {
  75.         eval __lsort -dictionary [lrange $args 1 end]
  76.         } else {
  77.         eval __lsort $args
  78.         }
  79.     }
  80.     rename glob __glob
  81.     proc glob {args} {
  82.         if {[lindex $args 0] == "-t"} {
  83.         eval __glob [lrange $args 2 end]
  84.         } else {
  85.         eval __glob $args
  86.         }
  87.     }
  88.     # Tcl 8.0 doesn't handle \t \r \n , but Tcl 8.1 will
  89.     if {[info tclversion] == 8.0} {
  90.         rename regexp __regexp
  91.         proc regexp {args} {
  92.         set i 0
  93.         while {[string match -* [set a [lindex $args $i]]]} {
  94.             incr i
  95.             if {$a == "--"} {
  96.             set a [lindex $args $i]
  97.             break
  98.             }
  99.         }
  100.         __regsub -all "\\\\t" $a "\t" a
  101.         __regsub -all "\\\\r" $a "\r" a
  102.         __regsub -all "\\\\n" $a "\n" a
  103.         __regsub -all "\\\\w" $a "\[a-zA-Z_\]" a
  104.         uplevel __regexp [lreplace $args $i $i $a]
  105.         }
  106.         rename regsub __regsub
  107.         proc regsub {args} {
  108.         set i 0
  109.         while {[string match -* [set a [lindex $args $i]]]} {
  110.             incr i
  111.             if {$a == "--"} {
  112.             set a [lindex $args $i]
  113.             break
  114.             }
  115.         }
  116.         __regsub -all "\\\\" $a "¢¢" a
  117.         __regsub -all "\\\\t" $a "\t" a
  118.         __regsub -all "\\\\r" $a "\r" a
  119.         __regsub -all "\\\\n" $a "\n" a
  120.         __regsub -all "\\\\w" $a "\[a-zA-Z_\]" a
  121.         __regsub -all "¢¢" $a "\\\\" a
  122.         uplevel __regsub [lreplace $args $i $i $a]
  123.         }
  124.     }
  125.     }    
  126.     
  127.     # Get Alpha's current name.
  128.     regexp {"([^"]+)" "ALFA" } [processes] "" ALPHA
  129.     # PREFS points to a folder 'Alpha', we add the major version number
  130.     set alpha::version [lindex [split [string trimleft [version] "Alpha Version"] ,] 0]
  131.     set alpha::tclversion ${alpha::version}
  132.     # This patch version will eventually disappear, I think, since it is now
  133.     # considered the version of the Alpha application, and should therefore
  134.     # come from the application itself (the C code).
  135.     set alpha::patchlevel ".8"
  136.     append alpha::version ${alpha::patchlevel}
  137.     # append patch-level to AlphaTcl version
  138.     set alpha::tclpatchlevel ".8"
  139.     append alpha::tclversion ${alpha::tclpatchlevel}
  140.     if {[info commands startupText] != ""} {
  141.     startupText "Alpha $alpha::version, AlphaTcl $alpha::tclversion, Tcl [info patchlevel]"
  142.     }
  143.     if {[regexp -nocase "for (ppc|68k)" [version]] || ![regexp "for" [version]]} {
  144.     set alpha::platform "alpha"
  145.     } 
  146.     
  147.     append PREFS "-v[lindex [split ${alpha::version} .] 0]"
  148.     if {![info exists alpha::modifier_keys]} {
  149.     set alpha::modifier_keys [list "Command" "cmd" "Option" "opt"]
  150.     }
  151.     # useful proc
  152.     if {[info tclversion] < 7.6} { 
  153.     set tcl_platform(platform) macintosh
  154.     # Alpha already has these two renamed internally
  155.     # they need their argument packaged as a list!
  156.     ;proc mkdir {dir} {
  157.         oldMkdir [list $dir]
  158.     }
  159.     ;proc rmdir {dir} {
  160.         oldRmdir [list $dir]
  161.     }
  162.     if {[info commands __file] == ""} {
  163.         rename file __file
  164.         ;proc file {cmd args} {
  165.         switch -- $cmd {
  166.             "join" {
  167.             regsub -all "::" [join $args ":"] ":" res
  168.             return $res
  169.             }
  170.             "copy" {eval copyFile $args}
  171.             "rename" {eval moveFile $args}
  172.             "delete" {
  173.             if {[file isdir [lindex $args 0]]} {
  174.                 eval rmdir $args
  175.             } else {
  176.                 eval removeFile $args
  177.             }
  178.             }
  179.             "mkdir" {eval mkdir $args}
  180.             "volumes" {
  181.             # Thanks to Jon
  182.             return [aebuild::result 'MACS' core getd ---- {obj {form:indx, want:type(cdis), seld:abso('all '), from:'null'()}} rtyp TEXT] 
  183.             }
  184.             default {uplevel 1 __file $cmd $args}
  185.         }
  186.         }
  187.     }
  188.     } 
  189.     # check if the user over-rides things
  190.     if {[file exists [file join ${HOME} AlphaPrefs]] \
  191.       && [file isdir [file join ${HOME} AlphaPrefs]]} {
  192.     set PREFS [file join ${HOME} AlphaPrefs]
  193.     } else {        
  194.     if {![file exists $PREFS]} { file mkdir $PREFS }
  195.     }
  196.     set alpha::noMenusYet 1
  197.     # source v. important code
  198.     source [file join $HOME Tcl SystemCode library.tcl]
  199.     source [file join $HOME Tcl SystemCode coreFixes.tcl]
  200.     alpha::makeAutoPath 0 $skipPrefs
  201.     # get known packages
  202.     catch {cache::read index::feature}
  203.     # if configuration has changed, rebuild indices
  204.     if {[alpha::checkConfiguration]} {
  205.     alertnote "I need to rebuild the package indices.\
  206.       This'll take just a few seconds."
  207.     # power-user can use 'option' to avoid the rebuild
  208.     if {!([getModifiers] & 72)} {
  209.         alpha::makeIndices
  210.         rebuildTclIndices
  211.     }
  212.     }
  213.  
  214.     if {[alpha::package vcompare ${alpha::version} 7.1d1] < 0} {
  215.     alertnote "This version of Alpha is too old.\
  216.       Upgrade from\
  217.       http://alpha.olm.net/ or\
  218.       ftp://ftp.ucsd.edu/alpha/ \
  219.       \r\rI'll quit now."
  220.     quit
  221.     }
  222.     # load the list of active packages from special cache
  223.     namespace eval global {}
  224.     set global::features ""
  225.     if {!$skipPrefs} {
  226.     catch {cache::read configuration}
  227.     catch {unset mode::defaultfeatures}
  228.     }
  229.     
  230. # Now do all the more complex stuff:
  231. # (from now on, avoid use of 'source'.  Prefer to use auto-loading)
  232.  
  233.     # pull in smarterSource and internationalMenus packages
  234.     # if the user activated them
  235.     set alpha::systempackages [list smarterSource internationalMenus]
  236.     if {[lsearch -exact ${global::features} smarterSource] != -1} {
  237.     alpha::package require smarterSource
  238.     }
  239.     if {[lsearch -exact ${global::features} internationalMenus] != -1} {
  240.     alpha::package require internationalMenus
  241.     }
  242.     
  243.     removeTemporaryFiles
  244.     alpha::getGlobalPreferences
  245.     alpha::getDefinitions
  246.     if {!$skipPrefs} {
  247.     # Read both scalar and array definitions from preferences folder.
  248.     alpha::readUserDefs
  249.     if {[key::optionPressed]} {
  250.     }
  251.     }
  252.     # define v. important keyboard variables
  253.     keys::keyboardChanged
  254.     menu::buildBasic
  255.     if {![info exists alpha::haveBasicKeys]} {
  256.     alpha::basicKeyBindings
  257.     }
  258.     alpha::keyBindings
  259.     alpha::useElectricTemplates
  260.     # Read in all packages, modes and menus.
  261.     alpha::findAllPlugins
  262.     if {!$skipPrefs} {
  263.     # read preferences file
  264.     if {[catch {alpha::readUserPrefs} err]} {
  265.         append alpha::errorLog "\r" $err
  266.         unset err
  267.     }
  268.     }
  269.     # call anything that's attached to my keyboard.
  270.     hook::callAll keyboard $keyboard
  271.     # build all menus completely.
  272.     alpha::buildMainMenus
  273.     # insert menus
  274.     global::insertAllMenus
  275.     # Bind special keys
  276.     bind::fromArray keys::specialBindings keys::specialProcs
  277.  
  278. # if we do anything else to a menu, it must now be rebuilt
  279. unset alpha::noMenusYet
  280.  
  281. # couple of random things
  282. alpha::makeColourList
  283.  
  284. # Add to chars considered part of words.
  285. addAlphaChars {_ÄÅÇÉÑÖÜáàâäãåçéèêëíìîïñóòôöõúùûüÅØæøæß}
  286. # Call all startup hooks
  287. hook::callAll startupHook *
  288. # Alerts and readme's for the user:
  289.  
  290.     if {!$skipPrefs} {
  291.         if {![info exists readReadme] \
  292.           || ($readReadme != [alpha::package versions Alpha])} {
  293.         addDef readReadme [alpha::package versions Alpha]
  294.         edit -r [file join $HOME Help Readme]
  295.         } else {unset readReadme}
  296.         
  297.         if {[info exists alpha::readAtStartup]} {
  298.         foreach f ${alpha::readAtStartup} {
  299.             catch {edit -r $f}
  300.         }
  301.         unset alpha::readAtStartup
  302.         lappend modifiedVars alpha::readAtStartup
  303.         }
  304.     }
  305.  
  306. } err]} {
  307.     append alpha::errorLog "\r" $errorInfo
  308.     if {[dialog::yesno -y "View the error" -n "Continue" "That was a core startup error.  Alpha will probably not function correctly."]} {
  309.     dialog::alert $errorInfo
  310.     }
  311. }
  312. if {[info exists alpha::errorLog]} {
  313.     catch {
  314.     new -n "* Alpha startup error log *" -info ${alpha::errorLog}
  315.     unset alpha::errorLog
  316.     }
  317. }
  318. # call these two procs to sort out the menu enabled state.
  319. catch {
  320.     menuEnableHook [expr {[win::Current] != ""}]
  321.     requireOpenWindowsHook 2
  322. }
  323. message "Initialization Complete"
  324.  
  325.  
  326.  
  327.